;;; -*- Mode:LISP; Package:TCP-APPLICATION; Base:10; Patch-File:T; Readtable:ZL -*-

;;; PATCH FOR RELEASE 2.0 FTP SERVER TO HANDLE BYTE SIZE 16 CORRECTLY.

(DEFUN FTP-SEND-DATA-FUNCTION (STATE INSTREAM OUTSTREAM DIRECTORY-P)
  (LET ((TRANSLATING-OUTSTREAM
          (SELECTQ (FTPSTATE-TRANSFER-TYPE STATE)
            (:ASCII
             (FTP:MAKE-ASCII-TRANSLATING-OUTPUT-STREAM OUTSTREAM))
            ((:IMAGE :LOGICAL-BYTE-SIZE)
             (SELECTQ (FTPSTATE-BYTE-SIZE STATE)
               (8 OUTSTREAM)
               (16 (MAKE-16B-TO-8B-TRANSLATING-OUTPUT-STREAM OUTSTREAM))))
            (T
             NIL)))
        (FTP:*HASH* NIL)
        (COMPLETEDP NIL))
    (UNWIND-PROTECT
        (COND ((NOT TRANSLATING-OUTSTREAM)
               (FTP-REPLY STATE 504 "Unimplemented type ~A." (FTPSTATE-TRANSFER-TYPE STATE)))
              ('ELSE
               (CONDITION-CASE-IF FTP-CATCH-ERRORS (ERR)
                   (PROGN (COND ((NOT DIRECTORY-P)
                                 (STREAM-COPY-UNTIL-EOF INSTREAM TRANSLATING-OUTSTREAM)
                                 (OR (EQ TRANSLATING-OUTSTREAM OUTSTREAM)
                                     (SEND TRANSLATING-OUTSTREAM :FORCE-OUTPUT)))
                                ((EQ DIRECTORY-P T)
                                 (DO ((ENTRY))
                                     ((NULL (SETQ ENTRY (SEND INSTREAM :LINE-IN))))
                                   (SEND TRANSLATING-OUTSTREAM :STRING-OUT ENTRY)
                                   (TERPRI TRANSLATING-OUTSTREAM)))
                                ((EQ DIRECTORY-P :DIRECTORY-LIST)
                                 (DO ((ENTRY))
                                     ((NULL (SETQ ENTRY (SEND INSTREAM :ENTRY))))
                                   (PRIN1 ENTRY TRANSLATING-OUTSTREAM)
                                   (TERPRI TRANSLATING-OUTSTREAM)))
                                ((EQ DIRECTORY-P :NAME-LIST)
                                 (SEND INSTREAM :ENTRY) ;; GET RID OF DISK-SPACE-DESCRIPTION
                                 (DO ((ENTRY))
                                     ((NULL (SETQ ENTRY (SEND INSTREAM :ENTRY))))
                                   (SEND TRANSLATING-OUTSTREAM :STRING-OUT
                                         (SEND (CAR ENTRY) :STRING-FOR-PRINTING))
                                   (TERPRI TRANSLATING-OUTSTREAM))))
                          (SETQ COMPLETEDP T))
                 (FS:FILE-ERROR
                  (FTP-FILE-ERROR-REPLY STATE ERR))
                 (ERROR (FTP-REPLY STATE 451 '"Local error in processing.") NIL))))
      (CLOSE INSTREAM)
      (IF COMPLETEDP (SEND OUTSTREAM :FORCE-OUTPUT))
      (FTP-CLEANUP-DATA-CONNECTION STATE NIL)
      (SETF (FTPSTATE-DATA-TRANSFER-IN-PROGRESS STATE) NIL)
      (IF COMPLETEDP (FTP-REPLY STATE 226 '"Transfer complete")))))



(DEFUN FTP-RECEIVE-DATA-FUNCTION (STATE INSTREAM OUTSTREAM &AUX SUCCESS)
  "Transfer the contents of net instream to local outstream"
 (CONDITION-CASE-IF FTP-CATCH-ERRORS (ERR)
  (SELECTQ (FTPSTATE-TRANSFER-TYPE STATE)
    (:ASCII
     (LET ((FTP:*HASH* NIL))
       (DECLARE (SPECIAL FTP:*HASH*))
       (WITH-OPEN-STREAM (IS (FTP:MAKE-ASCII-TRANSLATING-INPUT-STREAM INSTREAM))
         (STREAM-COPY-UNTIL-EOF IS OUTSTREAM)))
     (SETQ SUCCESS T))
    ((:IMAGE :LOGICAL-BYTE-SIZE)
     (SELECTQ (FTPSTATE-BYTE-SIZE STATE)
       (8
        (STREAM-COPY-UNTIL-EOF INSTREAM OUTSTREAM))
       (16
        (LET ((TRANS (MAKE-8B-TO-16B-TRANSLATING-OUTPUT-STREAM OUTSTREAM)))
          (STREAM-COPY-UNTIL-EOF INSTREAM TRANS)
          (SEND TRANS :FORCE-OUTPUT))))
     (SETQ SUCCESS T))
    (OTHERWISE (FERROR NIL '"Bad transfer type in FTPSTATE.")))
   (FS:FILE-ERROR (FTP-FILE-ERROR-REPLY STATE ERR) NIL)
   (ERROR (FTP-REPLY STATE 451 '"Local error in processing.") NIL))
 (CLOSE OUTSTREAM)
 (FTP-CLEANUP-DATA-CONNECTION STATE NIL)
 (SETF (FTPSTATE-DATA-TRANSFER-IN-PROGRESS STATE) NIL)
 (IF SUCCESS (FTP-REPLY STATE 226 '"Transfer complete.")))





(DEFFLAVOR 16B-TO-8B-TRANSLATING-OUTPUT-STREAM
         (OUTPUT)
         (SI:BUFFERED-OUTPUT-STREAM)
  (:INITABLE-INSTANCE-VARIABLES OUTPUT))

(DEFMETHOD (16B-TO-8B-TRANSLATING-OUTPUT-STREAM :NEW-OUTPUT-BUFFER) ()
  (DECLARE (VALUES ARRAY START END))
  (VALUES (allocate-resource 'FS:SIMPLE-ART-16B-BUFFER 1000)
          0
          1000))

(DEFMETHOD (16B-TO-8B-TRANSLATING-OUTPUT-STREAM :SEND-OUTPUT-BUFFER) (ARRAY END)
  (SEND OUTPUT
        :STRING-OUT
        (MAKE-ARRAY (* END 2) :TYPE 'ART-STRING :DISPLACED-TO ARRAY)
        0
        (* END 2))
  (DEALLOCATE-RESOURCE 'FS:SIMPLE-ART-16B-BUFFER ARRAY))

(DEFMETHOD (16B-TO-8B-TRANSLATING-OUTPUT-STREAM :DISCARD-OUTPUT-BUFFER) (ARRAY)
  (DEALLOCATE-RESOURCE 'FS:SIMPLE-ART-16B-BUFFER ARRAY))

(DEFFLAVOR 8B-TO-16B-TRANSLATING-OUTPUT-STREAM
         (OUTPUT)
         (SI:BUFFERED-OUTPUT-STREAM)
  (:INITABLE-INSTANCE-VARIABLES OUTPUT))

(DEFMETHOD (8B-TO-16B-TRANSLATING-OUTPUT-STREAM :NEW-OUTPUT-BUFFER) ()
  (DECLARE (VALUES ARRAY START END))
  (VALUES (allocate-resource 'FS:SIMPLE-STRING-BUFFER 2000)
          0
          2000))

(DEFMETHOD (8B-TO-16B-TRANSLATING-OUTPUT-STREAM :SEND-OUTPUT-BUFFER) (ARRAY END)
  (SEND OUTPUT :STRING-OUT (MAKE-ARRAY (FLOOR END 2)
                                       :TYPE 'ART-16B
                                       :DISPLACED-TO ARRAY))
  (DEALLOCATE-RESOURCE 'FS:SIMPLE-STRING-BUFFER ARRAY))

(DEFMETHOD (8B-TO-16B-TRANSLATING-OUTPUT-STREAM :DISCARD-OUTPUT-BUFFER) (ARRAY)
  (DEALLOCATE-RESOURCE 'FS:SIMPLE-STRING-BUFFER ARRAY))

(COMPILE-FLAVOR-METHODS 16B-TO-8B-TRANSLATING-OUTPUT-STREAM 8B-TO-16B-TRANSLATING-OUTPUT-STREAM)


(DEFUN MAKE-16B-TO-8B-TRANSLATING-OUTPUT-STREAM (OUTPUT)
  (MAKE-INSTANCE '16B-TO-8B-TRANSLATING-OUTPUT-STREAM :OUTPUT OUTPUT))

(DEFUN MAKE-8B-TO-16B-TRANSLATING-OUTPUT-STREAM (OUTPUT)
  (MAKE-INSTANCE '8B-TO-16B-TRANSLATING-OUTPUT-STREAM :OUTPUT OUTPUT))
